perm filename PASS2.F4[M5,LCS] blob
sn#107295 filedate 1975-07-16 generic text, type T, neo UTF8
CPASS2 PASS 2 MAIN PROGRAM
C *** MUSIC V ***
DIMENSIONG(1000),I(1000),T(1000),D(10000),P(100),IP(10)
COMMONIP,P,G,I,T,D,IXJQ,TLAST,BLAST
C INIALIZING PROGRAM
C NOMINAL SAMPLING RATE, NOTE PARAMETER LENGTH, NUMBER OF CARDS
C NO OF OP CODES, PASS II REPORT PRINT PARAMETER
G(1)=0.
G(2)=0.
G(4)=10000.0
NPAR=10000
NCAR=1000
NOPC=12
IXJQ=0
IEND=0
CC***** NREAD=2
CC***** NWRITE=3
NREAD=20
NWRITE=21
REWIND NREAD
REWIND NWRITE
C INIALIZE SECTION
150 ID=1
IN=1
TLAST=0.
BLAST=0.
C READ SECTION OF DATA
106 CALL READ2(NREAD)
I1=IP(1)
D(ID)=I1
I(IN)=ID
T(IN)=P(2)
DO 100I2=1,I1
I3=ID+I2
100 D(I3)=P(I2)
ID=ID+I1+1
IF(ID-NPAR)102,102,101
101 CALLERROR(20)
STOP
102 IN=IN+1
IF(IN-NCAR)103,103,101
103 IF(P(1)-5.0)104,110,104
104 IF(P(1)-6.0)106,105,106
105 IEND=1
GO TO 110
C SORT SECTION
C**** NOT USED ****** 110 CALLSORTFL
110 IN=IN-1
CALLSORT(T(1),T(2),IN,I)
C EXECUTE OP CODES M SECTION
120 DO 1I4=1,IN
I5=I(I4)
I6=D(I5+1)
IF(I6)121,121,122
121 CALLERROR(21)
GO TO 1
122 IF(I6-NOPC)123,123,121
123 GO TO (2,2,2,2,2,2,7,8,7,10,2,8),I6
7 CALLERROR(22)
GO TO 1
8 I7=D(I5)
I8=I5+4
I9=I5+I7
I10=IFIX(D(I5+3))-I8
DO 124I11=I8,I9
I12=I10+I11
124 G(I12)=D(I11)
IF(I6-12)1,2,1
10 I13=D(I5+3)
IP(2)=I5
IF(I13)125,125,126
125 CALLERROR(23)
GO TO 1
126 IF(I13-5)127,127,125
127 GO TO (21,22,23,24,25),I13
21 CALLPLS1
GO TO 1
22 CALLPLS2
GO TO 1
23 CALLPLS3
GO TO 1
24 CALLPLS4
GO TO 1
25 CALLPLS5
GO TO 1
C WRITE OUT SECTION
2 IP(1)=D(I5)
I18=IP(1)
DO 133I19=1,I18
I20=I19+I5
133 P(I19)=D(I20)
CALL WRITE2 (NWRITE)
1 CONTINUE
C END SECTION OR PASS
140 IF(IEND)141,141,143
141 PRINT142
142 FORMAT (' END OF SECTION PASS II')
GO TO 150
143 PRINT144
144 FORMAT (' END OF PASS II')
STOP
END
CREAD2 PASS 2 DATA INPUT ROUTINE
C *** MUSIC V ***
SUBROUTINEREAD2(N)
DIMENSIONIP(10),P(100)
COMMONIP,P
READ(N)K,(P(J),J=1,K)
IP(1)=K
RETURN
END
CSORT SORTING PROGRAM
C *** MUSIC V ***
SUBROUTINE SORT(A,B,N,L)
DIMENSION A(N),L(N)
C
C SORT SORTS THE A ARRAY INTO ASCENDING NUMERICAL ORDER, PERFORMING
C THE SAME OPERATIONS ON ARRAY L AS ON A
C
N1=N-1
DO 10 I=1,N1
IN=I+1
DO 20 J=IN,N
IF(A(I).LE.A(J))GO TO 20
T=A(I)
A(I)=A(J)
A(J)=T
NT=L(I)
L(I)=L(J)
L(J)=NT
20 CONTINUE
10 CONTINUE
RETURN
CC******* ENTRY SORTFL
CC******* RETURN
END
CWRIT2 DATA OUTPUTING ROUTINE FOR PASS 2
C *** MUSIC V ***
SUBROUTINE WRITE2(N)
COMMON IP(10),P(100),G(1000),I(1000),T(1000),D(10000),IXJQ,TLAST,B
1LAST
IF(G(2).EQ.0.)GO TO 150
X=P(2)
Y=P(4)
ILOC=G(2)
IF(P(1).NE.1.)GO TO 50
P(4)=P(4)*60./CON(G,ILOC,P(2))
50 P(2)=TLAST+(P(2)-BLAST)*60./CON(G,ILOC,P(2))
TLAST=P(2)
BLAST=X
150 CALL CONVT
K=IP(1)
WRITE(N)K,(P(J),J=1,K)
C *** PASS II REPORT IS OPTIONAL ***
IF(G(1).NE.0.)RETURN
IF(IXJQ.EQ.0)PRINT100
IXJQ=10
100 FORMAT(15H1PASS II REPORT/11H0(WORD CNT))
PRINT101,K,(P(J),J=1,K)
IF(G(2).NE.0.)PRINT102,X,Y
101 FORMAT(I8,10(F9.3))
102 FORMAT(1H+,110X,2HB=,F7.4,2HD=,F7.4)
RETURN
END
CCON2 PASS 2 FUNCTION INTERPOLATER
C *** MUSIC V ***
FUNCTION CON(G,I,T)
DIMENSION G(I)
DO 10 J=I,1000,2
IF (G(J)-T) 10,20,30
30 CON = G(J-1)+((T-G(J-2))/(G(J)-G(J-2)))*(G(J+1)-G(J-1))
RETURN
10 CONTINUE
20 CON = G(J+1)
RETURN
END
C CONVT FOR UNIT GENERATORS CHECK
C
C DUMMY NO OPERATION ACTUALLY PERFORMED
C****** WHEN DUMMY IS REMOVED ANOTHER CONVT MUST!!!! BE LOADED!!!*****
C*** SUBROUTINE CONVT
C*** COMMON IP(10),P(100),G(1000)
C*** RETURN
C*** END
CERRO1 GENERAL ERROR ROUTINE
C *** MUSIC V ***
SUBROUTINEERROR(I)
PRINT100,I
100 FORMAT (' ERROR OF TYPE',I5)
RETURN
END
CC***** SUBROUTINE PLS
CC***** ENTRY PLS1
CC***** ENTRY PLS2
CC***** ENTRY PLS3
CC***** ENTRY PLS4
CC***** ENTRY PLS5
CC***** END
SUBROUTINE PLS1
RETURN
END
SUBROUTINE PLS2
RETURN
END
SUBROUTINE PLS3
RETURN
END
SUBROUTINE PLS4
RETURN
END
SUBROUTINE PLS5
RETURN
END